-- Haskore Live!
--
-- David Siegel <djsiegel@seas.upenn.edu>
-- Jonathan Coveney <jcoveney@wharton.upenn.edu>
--
-- TrackState.hs
--

-- | Module 'TrackState' defines a state monad and operations for dealing with
-- track state.
module TrackState ( TrackState
                  , countTracks
                  , execTrackState
                  , getTrack
                  , getTracks
                  , nameTrack
                  , peekTrack
                  , popTrack
                  , pushTrack
                  , removeTrack
                  , validateIndex
                  , runTests
                  ) where

import Test.HUnit
import List (delete)
import Control.Monad.State

import qualified Track
import Performance (Performance)

-- | TrackState state.
data TrackStateVars =
    TrackStateVars { -- | List of Tracks (sometimes referred to as a stack).
                     tracks :: [Track.T]
                   }
    deriving (Eq)

-- | A state monad transformer on IO which contains a TrackStateVars record.
type TrackState = StateT TrackStateVars IO

-- | Runs a TrackState monad with a default state, returning the result.
execTrackState :: TrackState a -> IO a
execTrackState ts = do
    (x, s) <- runStateT ts (TrackStateVars [])
    return x

-- | Gets the number of Tracks stored in the monad.
countTracks :: TrackState Int
countTracks = liftM length getTracks

testCountTracks = TestCase $ do
    (count, state) <- runStateT countTracks zeroTracks
    count @?= 0

    (count, state) <- runStateT countTracks oneTrack
    count @?= 1

    where zeroTracks = TrackStateVars []
          oneTrack   = TrackStateVars [Track.T "" []]

-- | Validate an index for use with nameTrack, removeTrack, getTrack, etc.
validateIndex :: Int -> TrackState Bool
validateIndex i = do
    max <- countTracks
    return (i >= 0 && i < max)

testValidateIndex = TestCase $ do
    -- Test index too high (empty state).
    (valid, s) <- runStateT (validateIndex 1) zeroTracks
    valid @?= False

    -- Test max/min index at once.
    (valid, s) <- runStateT (validateIndex 0) oneTrack
    valid @?= True

    -- Test index too high.
    (valid, s) <- runStateT (validateIndex 1) oneTrack
    valid @?= False

    -- Test  index too low (negative index).
    (valid, s) <- runStateT (validateIndex (-1)) oneTrack
    valid @?= False

    where zeroTracks = TrackStateVars []
          oneTrack   = TrackStateVars [Track.T "" []]

-- | Gets the Tracks stored in the monad.
getTracks :: TrackState [Track.T]
getTracks = gets tracks

testGetTracks = TestCase $ do
    (ts, s) <- runStateT getTracks oneTrack
    ts @?= tracks oneTrack
    where oneTrack   = TrackStateVars [Track.T "" []]

-- | Gets a specific track by number. Caller must verify input using
-- countTracks.
getTrack :: Int -> TrackState Track.T
getTrack i = liftM (!! i) getTracks

testGetTrack = TestCase $ do
    -- Test getting the element at index 1.
    (t, s) <- runStateT (getTrack 1) ts
    t @?= t1
    where t0 = Track.T "zero" []
          t1 = Track.T "one" []
          ts = TrackStateVars [t0, t1]

-- | Sets the Tracks stored in the monad.
setTracks :: [Track.T] -> TrackState ()
setTracks ts = do
    s  <- get
    put $ s { tracks = ts }

testSetTracks = TestCase $ do
    -- Set non-empty tracks on empty state.
    s <- execStateT (setTracks ts) emptyState
    tracks s @?= ts
    where emptyState = TrackStateVars []
          ts         = [Track.T "" []]

-- | Gets the top of the Track stack. Caller must verify input using
-- countTracks.
peekTrack :: TrackState Track.T
peekTrack = getTrack 0

testPeekTrack = TestCase $ do
    (t, s) <- runStateT peekTrack ts
    t @?= t0
    where t0 = Track.T "zero" []
          t1 = Track.T "one" []
          ts = TrackStateVars [t0, t1]

-- | Pushes a Track onto the Tracks stack.
pushTrack :: Track.T -> TrackState ()
pushTrack t = do
    s  <- get
    ts <- getTracks
    put $ s { tracks = t : ts }

testPushTrack = TestCase $ do
    -- Push.
    s <- execStateT (pushTrack t0) emptyState
    tracks s @?= [t0]

    -- Push again.
    s' <- execStateT (pushTrack t1) s
    tracks s' @?= [t1, t0]

    where t0         = Track.T "zero" []
          t1         = Track.T "one" []
          emptyState = TrackStateVars []

-- | Pops a Track off the Track stack. Caller must verify input using
-- countTracks.
popTrack :: TrackState Track.T
popTrack = removeTrack 0

testPopTrack = TestCase $ do
    -- Pop.
    (t, s) <- runStateT popTrack ts
    t @?= t0

    -- Pop again.
    (t, s') <- runStateT popTrack s
    t @?= t1

    where t0 = Track.T "zero" []
          t1 = Track.T "one" []
          ts = TrackStateVars [t0, t1]

-- | Remove a Track at a given index. Caller must verify input using
-- countTracks.
removeTrack :: Int -> TrackState Track.T
removeTrack i = do
    ts <- getTracks
    t  <- getTrack i
    setTracks $ delete t ts
    return t

testRemoveTrack = TestCase $ do
    -- Test removing index 0.
    (t, s) <- runStateT (removeTrack 0) ts
    t @?= t0
    tracks s @?= [t1]

    -- Test removing index 1.
    (t, s) <- runStateT (removeTrack 1) ts
    t @?= t1
    tracks s @?= [t0]

    -- Test removing singleton.
    (t, s') <- runStateT (removeTrack 0) s
    t @?= t0
    tracks s' @?= []

    where t0 = Track.T "zero" []
          t1 = Track.T "one" []
          ts = TrackStateVars [t0, t1]

-- | Name a Track at a given index. Caller must verify input using countTracks.
nameTrack :: Int -> String -> TrackState ()
nameTrack i n = do
    ts <- getTracks
    t <- getTrack i
    let t' = Track.T n (Track.performance t)
    setTracks $ take i ts ++ [t'] ++ drop (i+1) ts

testNameTrack = TestCase $ do
    (_, s) <- runStateT (nameTrack 0 "bar") ts
    nameOfFirst s @?= "bar"
    where t0 = Track.T "foo" []
          ts = TrackStateVars [t0]
          nameOfFirst = Track.name . head . tracks

-- | Runs unit tests.
runTests = runTestTT $
    TestList [ TestLabel "testCountTracks" testCountTracks
             , TestLabel "testValidateIndex" testValidateIndex
             , TestLabel "testGetTracks" testGetTracks 
             , TestLabel "testGetTrack" testGetTrack 
             , TestLabel "testGetTrack" testSetTracks
             , TestLabel "testPeekTrack" testPeekTrack
             , TestLabel "testPushTrack" testPushTrack
             , TestLabel "testPopTrack" testPopTrack
             , TestLabel "testRemoveTrack" testRemoveTrack
             , TestLabel "testNameTrack" testNameTrack
             ]
